home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / dateunit.zip / DATEUNIT.PAS
Pascal/Delphi Source File  |  1992-01-02  |  9KB  |  335 lines
  1. (*
  2. #############################################################################
  3. #                                                                           #
  4. #  F R E D   D I B B E L    Hard- und Softwareentwicklung * 04121 / 92633   #
  5. #                           Dorfstrasse 132  *  W2200 Klein Nordende        #
  6. #                                               FRG                         #
  7. #############################################################################
  8.  
  9.         Copyright Fred Dibbel 1991
  10.  
  11. This unit can be modified and copied free, as log as this header will stay
  12. with the copy. Usuage is allowed for any NONCOMMERCIAL application. This
  13. means, if you want to use it in one of your programs which is not freeware,
  14. you have to contact me and ask for conditions to use BEFORE selling your
  15. product.
  16.  
  17. Comments are in german, sorry, but maybe somebody will translate.
  18.  
  19. *)
  20. {$D+,I-,R-,S-}
  21. unit datum;
  22.  
  23. {-----------------------------------------------------------------------
  24.      enthlt :
  25.                function dateok(datum:DateTime):boolean;
  26.                  berprft Datum auf kalendarische Richtigkeit
  27.  
  28.                function timeok(datum:DateTime):boolean;
  29.                  berprft Uhrzeit auf formale Richtigkeit
  30.  
  31.                function DateTimeOk(datum):boolean;
  32.                  beides zusammen
  33.  
  34.                procedure IncDaTi(var basis:DateTime; add:DateTime);
  35.                  basis wird um DeltaT(add) erhht
  36.  
  37.                Function WeekDay(datum:DateTime):byte;
  38.                  liefert day-of-week von datum  0=Sonntag .. 6=Samstag
  39.  
  40.                function DaysOfMonth(datum:DateTime):word;
  41.                  wieviel Tage hat der Monat ??
  42.  
  43.                procedure monday(tweek,tyear:word;var date:DateTime);
  44.                  liefert Anfangsdatum der Woche
  45.  
  46.                function week(datum:DateTime):word;
  47.                  liefert Kalenderwoche von Datum, 0 fr letzte Woche Vorjahr
  48.  
  49.                procedure TimeDiffer(a,b:DateTime;var c:TimeDiff);
  50.                  Zeitdifferenz zwischen a und b
  51.  
  52.                function EqualDT(a,b:DateTime):boolean;
  53.                  True wenn a=b
  54.  
  55.               function GreaterDT(a,b:DateTime):boolean;
  56.                 gibt TRUE bei a spter b
  57.  
  58.                function DezHours(datum:TimeDiff):real;
  59.                  Dezimalequivalent von datum
  60.  
  61. ------------------------------------------------------------------------}
  62.  
  63. interface
  64.  
  65. uses dos;
  66.  
  67. type    TimeDiff = record
  68.                      days : longint;
  69.                      hours,mins,secs: word;
  70.                    end;
  71.  
  72.  
  73.  
  74.   function dateok(datum:DateTime):boolean;
  75.   function timeok(datum:DateTime):boolean;
  76.   function DateTimeOk(datum:DateTime):boolean;
  77.   procedure IncDaTi(var basis:DateTime; add:DateTime);
  78.   Function WeekDay(datum:DateTime):byte;
  79.   function DaysOfMonth(datum:DateTime):word;
  80.   procedure monday(tweek,tyear:word;var date:DateTime);
  81.   procedure TimeDiffer(a,b:DateTime;var c:TimeDiff);
  82.   function EqualDT(a,b:DateTime):boolean;
  83.   function GreaterDT(a,b:DateTime):boolean;
  84.   function DezHours(datum:TimeDiff):real;
  85.   function week(datum:DateTime):word;
  86.  
  87.  
  88. implementation
  89.  
  90.   function leapyear(year:word):boolean;
  91.  
  92.   begin
  93.     if (year mod 4 = 0) and (year mod 100 <> 0) or (year mod 400 = 0)
  94.       then leapyear:=true
  95.       else leapyear:=false;
  96.   end;
  97.  
  98.  
  99.   function DaysOfMonth(datum:DateTime):word;
  100.  
  101.   begin
  102.     with datum do
  103.       Case month of  1,3,5,7,8,10,12 : DaysOfMonth:=31;
  104.                             4,6,9,11 : DaysOfMonth:=30;
  105.                                    2 : if leapyear(year) then DaysOfMonth:=29
  106.                                        else DaysOfMonth:=28
  107.             end;
  108.   end;
  109.  
  110.  
  111.   function dateok(datum:DateTime):boolean;
  112.  
  113.   begin
  114.     with datum do
  115.       dateok:=(month in [1..12]) and (day>0) and (day <=DaysOfMonth(datum));
  116.   end;
  117.  
  118.  
  119.   function timeok(datum:DateTime):boolean;
  120.  
  121.   begin
  122.     with datum do
  123.       timeok:=(hour in [0..23]) and (min in [0..59]) and (sec in [0..59]);
  124.   end;
  125.  
  126.  
  127.   function DateTimeOk(datum:DateTime):boolean;
  128.  
  129.   begin
  130.     DateTimeOk:=dateok(datum) and Timeok(datum);
  131.   end;
  132.  
  133.  
  134.   procedure DTForm(var datum:DateTime);
  135.  
  136.   begin
  137.     with datum do
  138.     begin
  139.       while sec>=60 do begin inc(min); dec(sec,60); end;
  140.       while min>=60 do begin inc(hour); dec(min,60); end;
  141.       while hour>=24 do begin inc(day); dec(hour,24); end;
  142.       while day>DaysOfMonth(datum) do
  143.         begin dec(day,DaysOfMonth(datum)); inc(month) end;
  144.       while month>12 do begin inc(year); dec(month,12) end;
  145.     end;
  146.   end;
  147.  
  148.  
  149.  
  150.  
  151.   procedure IncDaTi(var basis:DateTime; add:DateTime);
  152.  
  153.   begin
  154.     with basis do
  155.     begin
  156.       inc(day,add.day);DTForm(basis);
  157.       inc(hour,add.hour);DTForm(basis);
  158.       inc(min,add.min);DTForm(basis);
  159.       inc(sec,add.sec);DTForm(basis);
  160.       inc(month,add.month);DTForm(basis);
  161.       inc(year,add.year);
  162.     end;
  163.   end;
  164.  
  165.  
  166.   function faktor(datum:DateTime):longint;
  167.  
  168.   begin
  169.     with datum do
  170.     begin
  171.       if month in [1,2] then
  172.         faktor:=365*year + day + 31*(month - 1) + trunc((year - 1)/4.0) -
  173.               trunc(0.75*int(((year - 1)/100.0) + 1))
  174.       else faktor:=365*year + day + 31*(month - 1) - trunc(0.4*month + 2.3) +
  175.                  trunc(year/4.0) - trunc(0.75*int(((year - 1)/100.0) + 1));
  176.     end;
  177.   end;
  178.  
  179.  
  180.   Function WeekDay(datum:DateTime):byte;
  181.  
  182.   var   fakt : longint;
  183.  
  184.   begin
  185.     fakt:=faktor(datum);
  186.     fakt:=fakt - 7*trunc(fakt/7.0);
  187.     WeekDay:=(fakt + 7) mod 7;
  188.   end;
  189.  
  190.  
  191.   function EqualDT(a,b:DateTime):boolean;
  192.  
  193.   begin
  194.     equalDT:=(a.year=b.year) and (a.month=b.month) and (a.day=b.day) and
  195.              (a.hour=b.hour) and (a.min=b.min) and (a.sec=b.sec);
  196.   end;
  197.  
  198.  
  199.  
  200.   function GreaterDT(a,b:DateTime):boolean;
  201.  
  202.   var   greater : boolean;
  203.  
  204.   begin
  205.     greater:=(a.year>b.year);
  206.     if not greater and (a.year=b.year) then
  207.     begin
  208.       greater:=(a.month>b.month);
  209.       if not greater and (a.month=b.month) then
  210.       begin
  211.         greater:=(a.day>b.day);
  212.         if not greater and (a.day=b.day) then
  213.         begin
  214.           greater:=(a.hour>b.hour);
  215.           if not greater and (a.hour=b.hour) then
  216.           begin
  217.             greater:=(a.min>b.min);
  218.             if not greater and (a.min=b.min) then
  219.               greater:=(a.sec>b.sec);
  220.           end;
  221.         end;
  222.       end;
  223.     end;
  224.     GreaterDT:=greater;
  225.   end;
  226.  
  227.  
  228.  
  229.  
  230.   procedure TimeDiffer(a,b:DateTime;var c:TimeDiff);
  231.  
  232.   const  daysec    = 3600 * 24;
  233.  
  234.   var  fakta,faktb,daydiff : longint;
  235.        seca,secb,secd      : longint;
  236.  
  237.   begin
  238.     FillChar(c,SizeOf(c),0);
  239.     fakta:=faktor(a);faktb:=faktor(b);
  240.     seca:=a.sec + 60*a.min + 3600*a.hour;
  241.     secb:=b.sec + 60*b.min + 3600*b.hour;
  242.     daydiff:=0;
  243.     if fakta=faktb then
  244.       if seca=secb then exit
  245.       else if seca>secb then secd:=seca-secb
  246.            else secd:=secb-seca
  247.     else if fakta>faktb then
  248.          begin
  249.            daydiff:=fakta-faktb;
  250.            secd:=seca-secb;
  251.          end
  252.          else begin
  253.                 daydiff:=faktb-fakta;
  254.                 secd:=secb-seca;
  255.               end;
  256.     if secd<0 then
  257.     begin
  258.       secd:=daysec + secd;
  259.       dec(daydiff);
  260.     end;
  261.     with c do
  262.     begin
  263.       days:=daydiff;
  264.       secs:=secd mod 60;secd:=secd div 60;
  265.       mins:=secd mod 60;
  266.       hours:=secd div 60;
  267.     end;
  268.   end;
  269.  
  270.   procedure monday(tweek,tyear:word;var date:DateTime);
  271.  
  272.   var   wday,monweek : byte;
  273.         plus         : DateTime;
  274.         hyear        : word;
  275.  
  276.   begin
  277.     with date do
  278.     begin
  279.       sec:=0;min:=0;hour:=0;
  280.       year:=tyear;day:=1;month:=1;
  281.       wday:=WeekDay(date);
  282.       if wday>1 then day:=9 - wday else day:=2 - wday;
  283.     end;  { date = 1. Montag im Jahr }
  284.     monweek:=week(date);
  285.     if (tweek=0) or ((tweek=1) and (monweek=2)) then
  286.       with date do  { Woche beginnt im Vorjahr }
  287.       begin
  288.         dec(year);day:=31;month:=12;
  289.         hyear:=year;
  290.         monweek:=week(date);
  291.         monday(monweek,hyear,date);
  292.       end
  293.     else begin
  294.       if monweek=2 then dec(tweek);
  295.       fillchar(plus,sizeof(plus),0);
  296.       if tweek>1 then inc(plus.day,7*pred(tweek));
  297.       IncDaTi(date,plus);
  298.     end;
  299.   end;
  300.  
  301.   function week(datum:DateTime):word;
  302.  
  303.   var   datum2 : DateTime;
  304.         delta  : TimeDiff;
  305.         wday   : byte;
  306.         temp   : word;
  307.  
  308.   begin
  309.     with datum2 do
  310.     begin
  311.       year:=datum.year;month:=1;day:=1;
  312.       hour:=0;min:=0;sec:=0;
  313.     end;
  314.     TimeDiffer(datum2,datum,delta);
  315.     wday:=weekday(datum2);
  316.     if wday=0 then wday:=6 else dec(wday);
  317.     temp:=((delta.days + wday) div 7);
  318.     if wday < 4 then inc(temp);
  319.     week:=temp;
  320.   end;
  321.  
  322.  
  323.   function DezHours(datum:TimeDiff):real;
  324.  
  325.   begin
  326.     with datum do
  327.       dezhours:=24*days + hours + mins/60.0 + secs/3600.0;
  328.   end;
  329.  
  330.  
  331.   begin  {  }
  332.  
  333.  
  334.   end.
  335.